Shareware Grab Bag/Shareware Grab Bag.iso/050/soundeff.pas

Pascal/Delphi Source File | 1986-05-14 | 5KB | 315 lines

program sound_effects;

type
   longstring = string[80];

var
   x    : integer;
   thru : boolean;
   ch   : char;

procedure hilite(entry : longstring);

var
   rest : string[79];

begin
   rest := copy(entry,2,79);
   textcolor(lightblue);
   write(entry[1]);
   textcolor(blue);
   writeln(rest);
end;

procedure birdcall;

begin
   repeat
      sound(3500);
      delay(random(49));
      nosound;
      delay(50);
      sound(3000);
      delay(random(49));
      nosound;
      delay(50);
      sound(4000);
      delay(random(49));
      nosound;
      delay(50);
   until keypressed;
end;

procedure screech;

begin
   repeat
      x := 12000;
      while (x>1400) do
      begin
         sound(x);
         delay(6);
         x := x - 100;
      end;
   until keypressed;
   nosound;
end;

procedure clocktick;

begin
   repeat
      sound(12500);
      delay(19);
      nosound;
      delay(1000);
   until keypressed;
end;


procedure conveyor;

begin
   repeat
      for x := 37 to 100 do
      begin
         sound(x);
         delay(6);
      end;
   until keypressed;
   nosound;
end;

procedure doorbell;

var
   a : integer;

begin
   repeat
      for x := 1 to 20 do
      begin
         a := 5700;
         while (a < 16000) do
         begin
            sound(a);
            delay(5);
            nosound;
            a := a + 1500;
         end;
      end;
   delay(300);
   until keypressed;
end;

procedure generator;

begin
   for x := 37 to 300 do
   begin
      sound(x);
      delay(9);
      sound(2*x);
      delay(9);
      sound(3*x);
      delay(9);
   end;
   repeat
      sound(300);
      delay(9);
      sound(600);
      delay(9);
      sound(900);
      delay(9);
   until keypressed;
   nosound;
end;

procedure torpedo;

begin
   repeat
      x := 4000;
      while (x > 100) do
      begin
         sound(x);
         delay(2);
         sound(round(x/2+37));
         delay(2);
         sound(round(x/3+37));
         delay(2);
         x := x - 150;
      end;
      nosound;
      delay(random(800));
   until keypressed;
end;

procedure machine;

begin
   repeat
      x := 400;
      while (x > 100) do
      begin
         sound(x);
         delay(3);
         sound(round(x/2+37));
         delay(3);
         sound(round(x/3+37));
         delay(3);
         x := x - 10;
      end;
      nosound;
   until keypressed;
end;

procedure fazer;

begin
   repeat
      x := 300;
      while (x < 1800) do
      begin
         sound(x);
         delay(9);
         x := x + 100;
      end;
      nosound;
   until keypressed;
end;

procedure phone;

begin
   repeat
      for x := 1 to 30 do
      begin
         sound(523);
         delay(40);
         sound(659);
         delay(40);
      end;
      nosound;
      delay(1400);
   until keypressed;
end;

procedure faucet;

begin
   repeat
      x := 800;
      while (x < 1000) do
      begin
         sound(x);
         delay(8);
         x := x + 100;
      end;
      nosound;
      delay(2000);
   until keypressed;
end;

procedure computer;

begin
   repeat
      sound(random(2000));
      delay(40);
   until keypressed;
   nosound;
end;

procedure explosion;

var
   a : integer;

begin
   repeat
      for x := 1 to 5 do
      begin
         a := 300;
         while (a < 1800) do
         begin
            sound(a);
            delay(8);
            a := a + 150;
         end;
      end;
      nosound;
   until keypressed;
end;

procedure saucer;

begin
   repeat
      x := 500;
      while (x < 1500) do
      begin
         sound(x);
         delay(41);
         x := x + 200;
      end;
      nosound;
   until keypressed;
end;


procedure control;

begin
  while not thru do
  begin
   clrscr;
   textcolor(blue);
   write('                       SOUND EFFECTS DEMONSTRATION                             ');
   gotoxy(1,5);
   hilite('A Computer Thinking');
   hilite('Bird Call');
   hilite('Conveyor Belt');
   hilite('Doorbell');
   hilite('Explosion');
   hilite('Fazer Fire');
   hilite('Generator Starting');
   hilite('Hawk Screech');
   hilite('Leaking Faucet');
   hilite('Machine Noise');
   hilite('Photon Torpedo');
   hilite('Ringing Phone');
   hilite('Saucer');
   hilite('Ticking Clock');
   writeln('* - End');
   repeat until keypressed;
   read(kbd,ch);
   case upcase(ch) of
     'B' : birdcall;
     'H' : screech;
     'T' : clocktick;
     'C' : conveyor;
     'D' : doorbell;
     'G' : generator;
     'P' : torpedo;
     'M' : machine;
     'F' : fazer;
     'R' : phone;
     'L' : faucet;
     'A' : computer;
     'E' : explosion;
     'S' : saucer;
     '*' : thru := true;
     else writeln('Sorry, not implemented yet!');
   end;
  end;
end;

begin
   thru := false;
   control;
end. true;
     else writeln('Sorry, not implemented yet!');
   end;
  end;
en